home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 5 / Apprentice-Release5.iso / Environments / PowerMacOberon feb96 / Source / Reals.Mod (.txt) < prev    next >
Encoding:
Oberon Text  |  1994-07-26  |  2.9 KB  |  104 lines  |  [.Ob./.Ob4]
  1. Syntax10.Scn.Fnt
  2. StampElems
  3. Alloc
  4. 26 Jul 94
  5. MODULE Reals;
  6.     (* JT, 5.2.90 / RC 9.12.91 conversion between reals and strings for MIPS R2000*) (* MB 9.12.91*)
  7.     (* mah 
  8.  PowerMac *)
  9.     IMPORT
  10.         SYSTEM, MathL;
  11.     TYPE
  12.         CharPtr = POINTER TO ARRAY 64 OF CHAR;
  13.     PROCEDURE Ten*(e: INTEGER): REAL;
  14.         VAR r, power: LONGREAL;
  15.     BEGIN r := 1.0;
  16.         power := 10.0;
  17.         WHILE e > 0 DO
  18.             IF ODD(e) THEN r := r * power END;
  19.             power := power * power; e := e DIV 2
  20.         END ;
  21.         RETURN SHORT(r)
  22.     END Ten;
  23.     PROCEDURE TenL*(e: INTEGER): LONGREAL;
  24.         VAR r, power: LONGREAL;
  25.     BEGIN r := 1.0;
  26.         power := 10.0;
  27.         LOOP
  28.             IF ODD(e) THEN r := r * power END ;
  29.             e := e DIV 2;
  30.             IF e <= 0 THEN RETURN r END ;
  31.             power := power * power
  32.         END
  33.     END TenL;
  34.     PROCEDURE Expo*(x: REAL): INTEGER;
  35.     BEGIN
  36.         RETURN SHORT(ASH(SYSTEM.VAL(LONGINT, x), -23) MOD 256)
  37.     END Expo;
  38.     PROCEDURE ExpoL*(x: LONGREAL): INTEGER;
  39.         VAR h: LONGINT;
  40.     BEGIN
  41.         SYSTEM.GET(SYSTEM.ADR(x), h);
  42.         RETURN SHORT(ASH(h, -20) MOD 2048)
  43.     END ExpoL;
  44.     PROCEDURE SetExpo*(e: INTEGER; VAR x: REAL);
  45.         CONST expo = {1..8};
  46.     BEGIN
  47.         x := SYSTEM.VAL(REAL, SYSTEM.VAL(SET, x) - expo + SYSTEM.VAL(SET, ASH(LONG(e), 23)))
  48.     END SetExpo;
  49.     PROCEDURE SetExpoL*(e: INTEGER; VAR x: LONGREAL);
  50.         CONST expo = {1..11};
  51.         VAR h: SET;
  52.     BEGIN
  53.         SYSTEM.GET(SYSTEM.ADR(x), h);
  54.         h := h - expo + SYSTEM.VAL(SET, ASH(LONG(e), 20));
  55.         SYSTEM.PUT(SYSTEM.ADR(x), h)
  56.     END SetExpoL;
  57.     PROCEDURE Convert*(x: REAL; n: INTEGER; VAR d: ARRAY OF CHAR);
  58.         VAR i, k: LONGINT;
  59.     BEGIN
  60.         i := ENTIER(x); k := 0;
  61.         WHILE k < n DO
  62.             d[k] := CHR(i MOD 10 + 48); i := i DIV 10; INC(k)
  63.         END
  64.     END Convert;
  65.     PROCEDURE ConvertL*(x: LONGREAL; n: INTEGER; VAR d: ARRAY OF CHAR);
  66.         VAR i: LONGINT; buf: MathL.String;
  67.     BEGIN
  68.         (*x := x - 0.5; already rounded in ecvt*)
  69.         buf := SYSTEM.VAL(MathL.String, MathL.ecvt(x, n+7));
  70.         n:=0; WHILE buf[n]#CHR(0) DO INC(n) END ;
  71.         i:=4; WHILE i#n DO d[i-4] := buf[n-i-1]; INC(i) END ;
  72.         IF d[i-5]='-' THEN DEC(i) END;
  73.         d[i-6]:=d[i-5];
  74.         d[i-5]:=CHR(0);
  75.     END ConvertL;
  76. (*    PROCEDURE ConvertL*(x: LONGREAL; n: INTEGER; VAR d: ARRAY OF CHAR);
  77.         VAR decpt, sign, i: LONGINT; buf: CharPtr;
  78.     BEGIN
  79.         (*x := x - 0.5; already rounded in ecvt*)
  80.         buf := SYSTEM.VAL(CharPtr, MathL.ecvt(x, n-7));
  81.         i := 0;
  82.         WHILE i < decpt DO d[n - i -1] := buf[i]; INC(i) END ;
  83.         i := n - i - 1;
  84.         WHILE i >= 0 DO d[i] := "0"; DEC(i) END ;
  85.     END ConvertL; *)
  86.     PROCEDURE Unpack(VAR b, d: ARRAY OF SYSTEM.BYTE);
  87.         VAR i, k: SHORTINT; len: LONGINT;
  88.     BEGIN i := 0; len := LEN(b);
  89.         WHILE i < len DO
  90.             k := SHORT(ORD(SYSTEM.VAL(CHAR, b[i])) DIV 16);
  91.             IF k > 9 THEN d[i*2] := k + 55 ELSE d[i*2] := k + 48 END ;
  92.             k := SHORT(ORD(SYSTEM.VAL(CHAR, b[i])) MOD 16);
  93.             IF k > 9 THEN d[i*2+1] := k + 55 ELSE d[i*2+1] := k + 48 END ;
  94.             INC(i)
  95.         END
  96.     END Unpack;
  97.     PROCEDURE ConvertH* (y: REAL; VAR d: ARRAY OF CHAR);
  98.     BEGIN Unpack(y, d)
  99.     END ConvertH;
  100.     PROCEDURE ConvertHL* (x: LONGREAL; VAR d: ARRAY OF CHAR);
  101.     BEGIN Unpack(x, d)
  102.     END ConvertHL;
  103. END Reals.
  104.